{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleContexts #-}

module Tests {- () -} where

-- http://www.cs.chalmers.se/~rjmh/QuickCheck/manual.html

import Test.QuickCheck.Batch
import Test.QuickCheck
import Data.List (sort, nub)
import Monad (liftM, liftM2)
import Data.Maybe (catMaybes)

import Utility
import Cyc
import Theory

default ()

{-
prop_m xs | length (nub xs) <= 1 = m == Just 0
          | otherwise            =    (monotonic sorted == Just 1)
                                   && (monotonic rev == Just (-1))
                                   && if    (sorted /= xs)
                                         && (rev /= xs)
                                      then m == Nothing
                                      else True
          where sorted = sort xs
                rev    = reverse sorted
                m      = monotonic xs
-}

-- advantages of this style: violated requirement is individually identified in a failure
--                           input is regenerated until constraint satisfied (this is key)
-- disadvantages: have to name each property
--                lose shared type sigs, ==> constraints, and operations (sorting, reversing, monotonic, etc)

-- |a list with one or fewer unique elements is constant (trivial monotone)
prop_m4 :: Ord a => [a] -> Property
prop_m4 xs = length (nub xs) <= 1           ==> monotonic xs == Just 0

-- |a sorted list with at least 2 unique elements is monotone ascending
prop_m1 :: Ord a => [a] -> Property
prop_m1 xs = (atLeast 2 $ nub xs)           ==> monotonic (sort xs) == Just 1

-- |the reverse of a sorted list with at least 2 unique elements is monotone descending
prop_m2 :: Ord a => [a] -> Property
prop_m2 xs = (atLeast 2 $ nub xs)           ==> monotonic (reverse $ sort xs) == Just (-1)

-- |a list not equal to its sort or the reverse of its sort is not monotone
prop_m3 :: Ord a => [a] -> Property
prop_m3 xs = (xs /= s && xs /= (reverse s)) ==> monotonic xs == Nothing
    where s = sort xs

-- |Steppable identity
prop_s :: Steppable a => a -> Bool
prop_s x = halfStepsAbove x x == 0

-- |Steppable additive inverse
prop_f :: Steppable a => a -> a -> Bool
prop_f x y = halfStepsAbove x y == - (halfStepsAbove y x)

-- |traveling a certain number of steps is isarithmic to traveling the corresponding metric
-- could anything be invariant about the number of loops?
prop_mt1 :: (MetricCyc Int b) => b -> Int -> Bool  -- DON"T WANT MetricCyc Int, but compiler requires it and XFlexibleContexts to say it, how get rid of?
prop_mt1 p n = (isarithmic (0::Int) r ri) -- DON"T WANT this ::Int
    where r = travel n p
          m = (metricDist n p)::Int -- DON"T WANT this ::Int...
          Just (_::Int,ri) = metricTravel m p -- DON"T WANT the ::Int here, but compiler required it, and XScopedTypeVariables to say it, how get rid of?

-- |traveling an integer number of loopMetrics is isarithmic and reports that number of loops
-- should have separate test for noninteger number of loops, but what is invariant?
-- also do some of these on a MetricCyc with loopMetric of 0, and a very long bumpy one with very slow decline
prop_mt2 :: (Integral c, MetricCyc Int b) => c -> b -> Bool  -- DON"T WANT Int specified on MetricCyc -- but compiler required it, and XFlexibleContexts to say it, how get rid of?
prop_mt2 n p = (isarithmic (0::Int) r p) && m == n
    where Just (m,r) = metricTravel ((fromIntegral n) * ((loopMetric p)::Int {- `asTypeOf` (head $ metric p) -} )) p  -- DON"T WANT Int specified on loopMetric, but compiler required it, how get rid of?

-- |metric additive inverse is isarithmic
-- ugly to check that if there's no path in one direction of exactly the requested length that there's also none in the other direction
-- how clean this up?
prop_mt3 :: MetricCyc Int b => Int -> b -> Bool -- DON"T WANT MetricCyc Int, compiler required it and XFlexibleContexts to say it, how get rid of?
prop_mt3 n p = case metricTravel n p of
                    Nothing          -> not $ p `elem` ps
                        where ps = foldr (\x -> case (metricTravel (-n) x) of -- make sure if there was no path in one direction that there's also none in the other direction
                                                Nothing        -> id
                                                Just(_::Int,q) -> (q :) -- can't use catMaybes without depending on defaulting cuz of the Inegral constraint satisfied by this line
                                          ) [] $ list `asTypeOf` [p]
                    Just (_::Int,pk) -> isarithmic (0::Int) p pj -- numLoops is not straightforward -- DON"T WANT these ::Ints
                        where Just (_::Int,pj) = metricTravel (-n) pk -- DON"T WANT this ::Int

{-
class Num a => Divable a where
    dm :: (Integral b, Num c) => a -> a -> (b,c)

instance Integral a => Divable a a where
    dm = divMod

instance Fractional a => Divable a a where
    dm x y = (q, x - (q * x))
        where q = x / y
-}

----------------------------------------

{- this works for defining everyone in this section, but in combintation with the Integral def, gives a 'duplicate instance declaration' error, i guess cuz something could be all three Integral, Enum, and Bounded
instance (Enum a, Bounded a) => Arbitrary a where
    arbitrary = elements list
    coarbitrary = undefined
-}

instance Arbitrary Accidental where
    arbitrary = elements list
    coarbitrary = undefined

instance Arbitrary WhiteKey where
    arbitrary = elements list
    coarbitrary = undefined

instance Arbitrary PitchClass where
    arbitrary = liftM2 PitchClass arbitrary arbitrary
    coarbitrary = undefined

----------------------------------------

instance (Integral a) => Arbitrary a where
    arbitrary = fromInteger `liftM` arbitrary
    coarbitrary = undefined

{- this works, but only if in file where newtype Chord is
instance Arbitrary Chord where
    arbitrary = chord `liftM` arbitrary
    coarbitrary = undefined
-}

----------------------------------------

options :: TestOptions
options = TestOptions
        { no_of_tests         = 200
        , length_of_tests     = 0  -- secs allowed
        , debug_tests         = False
        }

main :: IO ()
main = do
{-
    let options = TestOptions
        { no_of_tests         = 200
        , length_of_tests     = 0  -- secs allowed
        , debug_tests         = False
        }
-}
    runTests "simple" options
        [ run (prop_m1 :: [Integer] -> Property)
        , run (prop_m2 :: [Integer] -> Property)
        , run (prop_m3 :: [Integer] -> Property)
        , run (prop_m4 :: [Integer] -> Property)

        , run (prop_s :: WhiteKey -> Bool)
        , run (prop_s :: Accidental -> Bool)
        , run (prop_s :: Note -> Bool)
--      , run (prop_s :: Octave -> Bool)
--      , run (prop_s :: MidiNum -> Bool)
        , run (prop_s :: PitchClass -> Bool)

        , run (prop_f :: WhiteKey -> WhiteKey -> Bool)
        , run (prop_f :: Accidental -> Accidental -> Bool)
        , run (prop_f :: Note -> Note -> Bool)
--      , run (prop_f :: Octave -> Octave -> Bool)
--      , run (prop_f :: MidiNum -> MidiNum -> Bool)
        , run (prop_f :: PitchClass -> PitchClass -> Bool)

        , run (prop_mt1 :: WhiteKey -> Int -> Bool)
        , run (prop_mt1 :: PitchClass -> Int -> Bool)
        , run (prop_mt2 :: Int -> WhiteKey -> Bool)
        , run (prop_mt2 :: Int -> PitchClass -> Bool)
        , run (prop_mt3 :: Int -> WhiteKey -> Bool)
        , run (prop_mt3 :: Int -> PitchClass -> Bool)
        ]

-- runhaskell QC.hs Tests.hs
